; utils

(defmacro if-it (var then &optional else)
  `(let ((it ,var))
    (if it ,then ,else)))

(defmacro when-it (var &body body)
  `(let ((it ,var))
    (when it
      ,@body)))

(defmacro case-it (var &body body)
  `(let ((it ,var))
    (case it
      ,@body)))



; ant
(defun other_color (c)
  (ecase c
    ('red 'black)
    ('black 'red)))

(defclass ant ()
  ((id :initarg :id :reader id)
   (color :initarg :color :reader color)
   (state :initform 0 :accessor state)
   (resting :initform 0 :accessor resting)
   (direction :initform 0 :accessor direction)
   (has_food :initform nil :accessor has_food)))

(defconstant +ant-number+ 32)

(defparameter *ants* (make-array +ant-number+ :initial-element nil))

(defparameter *ant-pos* (make-array +ant-number+ :initial-element nil))

(defun init-ant (c x y)
  (let ((id (next-id)))
    (setf (elt *ant-pos* id) (cons x y))
    (setf (elt *ants* id) (make-instance 'ant :id id :color c))))
	  

(let ((id 0))
  (defun next-id ()
    (prog1 id
      (incf id)))
  (defun re-init ()
    (setf id 0)
    (init-random)))


; cell

(defun adjacent_cell (p d)
  (destructuring-bind (x . y) p
     (ecase d
       (0 (cons (1+ x) y))
       (1 (cons (if (evenp y) x (1+ x)) (1+ y)))
       (2 (cons (if (evenp y) (1- x) x) (1+ y)))
       (3 (cons (1- x) y))
       (4 (cons (if (evenp y) (1- x) x) (1- y)))
       (5 (cons (if (evenp y) x (1+ x)) (1- y))))))

(defclass cell ()
  ((rocky :initarg :rocky :initform nil :reader rockyp)
   (ant-ref :initarg :ant-ref :initform nil :accessor ant-ref)
   (markers :initform (make-array 2 :initial-element 0) :accessor markers)
   (food :initarg :food :initform 0  :accessor food-in-cell)
   (hill :initarg :hill :initform nil :reader hill-color)))

(defparameter *cells* nil)

(defun read-cells (filespec)
  (with-open-file (in filespec)
    (let ((w (read in))
	  (h (read in)))
      (setf *cells* (make-array (list w h) :element-type 'cell))
      (dotimes (i h)
	(dotimes (j w)
	  (setf (aref *cells* i j)
		(apply #'make-instance 'cell
		       (case-it (prog1 (read-char in)
				  (read-char in nil)
				  (let ((char (read-char in nil)))
				    (unless (eql char #\Space)
				      (when char
					(unread-char char in)))))
			 (#\# (list :rocky t))
			 (#\. nil)
			 (#\+ (list :hill 'red :ant-ref (init-ant 'red i j)))
			 (#\- (list :hill 'black :ant-ref (init-ant 'black i j)))
			 (otherwise (list :food (parse-integer (string it)))))))))))) 


(defun get-cell (p)
  (aref *cells* (car p) (cdr p)))

(defun sensed_cell (p d sd)
  (ecase sd
    ('here p)
    ('ahead (adjacent_cell p d))
    ('leftahead (adjacent_cell p (turn-dir 'left d)))
    ('rightahead (adjacent_cell p (turn-dir 'right d)))))

(defun rocky (p)
  (rockyp (get-cell p)))

(defun some_ant_is_at (p)
  (when (ant-ref (get-cell p))
    t))

(defun ant_at (p)
  (ant-ref (get-cell p)))

(defun set_ant_at (p a)
  (setf (ant-ref (get-cell p)) a)
  (setf (elt *ant-pos* (id a)) p))

(defun clear_ant_at (p)
  (setf (ant-ref (get-cell p)) nil))

(defun ant_is_alive (id)
  (elt *ants* id))

(defun find_ant (id)
  (when (ant_is_alive id)
    (elt *ant-pos* id)))

(defun kill_ant_at (p)
  (setf (elt *ants* (id (ant_at p))) nil)
  (clear_ant_at p))

(defun food_at (p)
  (food-in-cell (get-cell p)))

(defun set_food_at (p f)
  (setf (food-in-cell (get-cell p)) f))

(defun anthill_at (p c)
  (eql (hill-color (get-cell p)) c))


; chemistry

(defun get-markers (p c)
  (elt (markers (get-cell p))
       (ecase c
	 ('black 0)
	 ('red 1))))

(defun set_marker_at (p c i)
  (unless (rocky p)
    (setf (ldb (byte 1 i)
	       (elt (markers (get-cell p))
		    (ecase c
		      ('black 0)
		      ('red 1))))
	  1)))

(defun clear_marker_at (p c i)
  (unless (rocky p)
    (setf (ldb (byte 1 i)
	       (elt (markers (get-cell p))
		    (ecase c
		      ('black 0)
		      ('red 1))))
	  0)))

(defun check_marker_at (p c i)
  (logbitp i (get-markers p c)))

(defun check_any_marker_at (p c)
  (> (get-markers p c) 0))

; probing

(defun cell_matches (p cond c &optional i)
  (if (rocky p) (eql cond 'rock)
      (ecase cond
	('friend (and (some_ant_is_at p)
		      (eql (color (ant_at p)) c)))
	('foe (and (some_ant_is_at p)
		   (eql (color (ant_at p)) (other_color c))))
	('friendwithfood (let ((ant_p (ant_at p)))
			  (and (some_ant_is_at p)
			       (eql (color ant_p) c)
			       (has_food ant_p))))
	('foewithfood (let ((ant_p (ant_at p)))
			  (and (some_ant_is_at p)
			       (eql (color ant_p) (other_color c))
			       (has_food ant_p))))

	('food (food_at p))
	('rock nil)
	('marker (check_marker_at p c i))
	('foemarker (check_any_marker_at p (other_color c)))
	('home (anthill_at p c))
	('foehome (anthill_at p (other_color c))))))


; instructions

(defparameter *black-instructions* (make-array 1000 :initial-element nil))
(defparameter *red-instructions* (make-array 1000 :initial-element nil))

(defun get_instruction (c s)
  (elt (get-instruction-set c) s))

(defmacro get-instruction-set (c)
  `(ecase ,c
     ('black *black-instructions*)
     ('red *red-instructions*)))

(defun read-instruction-set (c filespec)
  (with-open-file (in filespec)
    (loop for instr = (read-line in nil) while instr
	  for i = 0 then (incf i) while (< i 1000)
	  do (setf (elt (get-instruction-set c) i)
		   (with-input-from-string (tokens instr)
		     (loop for token = (read tokens nil) while (and token (not (eql token '|;|)))
			   collect token))))))



(defun exec (a p instruction)
  (apply (car instruction) a (append (list p) (cdr instruction))))


(defmacro def-instr (name (&rest args) &body body)
  `(defun ,name (a p ,@args)
     ,@body))

(def-instr sense (sensedir st1 st2 cond &optional i)
  (setf (state a)
	(if (cell_matches (sensed_cell p (direction a) sensedir) cond (color a) i)
	    st1 st2)))

(def-instr mark (i st)
  (set_marker_at p (color a) i)
  (setf (state a) st))

(def-instr unmark (i st)
  (clear_marker_at p (color a) i)
  (setf (state a) st))

(def-instr pickup (st1 st2)
  (if (or (has_food a) (= (food_at p) 0)) (setf (state a) st2)
      (progn
	(set_food_at p (1- (food_at p)))
	(setf (has_food a) t)
	(setf (state a) st1))))

(def-instr drop (st)
  (when (has_food a)
    (set_food_at p (1+ (food_at p)))
    (setf (has_food a) nil))
  (setf (state a) st))

(def-instr turn (lr st)
  (setf (direction a) (turn-dir lr (direction a)))
  (setf (state a) st))

(def-instr move (st1 st2)
  (let ((newp (adjacent_cell p (direction a))))
    (if (or (rocky newp) (some_ant_is_at newp)) (setf (state a) st2)
	(progn
	  (clear_ant_at p)
	  (set_ant_at newp a)
	  (setf (state a) st1)
	  (setf (resting a) 14)
	  (check_for_surrounded_ants newp)))))
	
(def-instr flip (n st1 st2)
  (setf (state a)
	(if (= (randomint n) 0) st1 st2)))


; kill

(defun adjacent_ants (p c)
  (let ((n 0))
    (dotimes (d 6)
      (let ((cell (adjacent_cell p d)))
	(when (and (some_ant_is_at cell)
		   (eql (color (ant_at cell)) c))
	  (incf n))))
    n))

(defun check_for_surrounded_ant_at (p)
  (when (some_ant_is_at p)
    (let ((a (ant_at p)))
      (when (> (adjacent_ants p (other_color (color a))) 4)
	(kill_ant_at p)
	(set_food_at p (+ (food_at p) 3 (if (has_food a) 1 0)))))))

(defun check_for_surrounded_ants (p)
  (check_for_surrounded_ant_at p)
  (dotimes (d 6)
    (check_for_surrounded_ant_at (adjacent_cell p d))))


; random

(defparameter *si* 12345) ; initial seed

(defun calc-si+1 ()
  (setf *si* (1+ (* *si* 22695477))))

(defun init-random ()
  (loop repeat 3
        do (calc-si+1)))

(defun xi ()
  (mod (floor (calc-si+1) 65536) 16384))

(defun randomint (n)
  (mod (xi) n))


; ops

(defun turn-dir (lr d)
  (ecase lr
    ('left  (mod (+ 5 d) 6))
    ('right (mod (+ 1 d) 6))))

(defun step-ant (id)
  (when (ant_is_alive id)
    (let* ((p (find_ant id))
	   (a (ant_at p)))
      (if (> (resting a) 0) (decf (resting a))
	  (exec a p (get_instruction (color a) (state a)))))))


; init-world

(defun init-world (map-file black-file red-file)
  (re-init-id)
  (read-cells map-file)
  (read-instruction-set 'black black-file)
  (read-instruction-set 'red red-file))

(defun run-cycle ()
  (dotimes (i +ant-number+)
    (step-ant i)))

(defun dump-world ()
  (with-output-to-string (out)
    (format out "~{~a~%~}" (array-dimensions *cells*))
    (destructuring-bind (w h) (array-dimensions *cells*)
      (dotimes (i h)
	(dotimes (j w)
	  (let ((cell (aref *cells* i j)))
	    (format out "~a ~@[~a ~]~@[~a ~]food: ~a ~%"
		    (cond
		      ((rockyp cell) "#")
		      ((hill-color cell) (format nil (ecase (hill-color cell)
						       ('black "-")
						       ('red "+"))))
		      (t (format nil ".")))
		    (format nil "~{~@[ ~a~]~}"
			    (list
			     (when (check_any_marker_at (cons i j) 'black)
			       (format nil "black-markers: ~{~a~}"
				       (loop for k = 0 then (incf k) repeat 6
					  for marker-p = (check_marker_at (cons i j) 'black k)
					  when marker-p collect k)))
			     (when (check_any_marker_at (cons i j) 'red)
			       (format nil "red-markers: ~{~a~}"
				       (loop for k = 0 then (incf k) repeat 6
					  for marker-p = (check_marker_at (cons i j) 'red k)
					  when marker-p collect k)))))
		    (when-it (ant-ref cell)
		      (format nil "~(~a~)-ant ~a~@[ with food~]" (color it) (id it) (has_food it)))
		    (food-in-cell cell))))
	(format out "~%")))))

(defun run-world (n)
  (dotimes (i n)
    (format t "iteration: ~a~%" i)
    (run-cycle))
  (destructuring-bind (w h) (array-dimensions *cells*)
    (let ((black-rez 0)
	  (red-rez 0))
      (dotimes (i h)
	(dotimes (j w)
	  (let ((cell (aref *cells* i j)))
	    (case (hill-color cell)
	      ('black (incf black-rez (food-in-cell cell)))
	      ('red (incf red-rez (food-in-cell cell)))))))
      (list black-rez red-rez))))